COMMENT ⊗   VALID 00003 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	 Chart Making program
C00004 00003	 The lines of a box are segments. So a Box would look like:
C00019 ENDMK
C⊗;
;;; Chart Making program
;;;	(...(benchmark 
;;;	     (impl1 entry1) (impl2 entry2)...) ...)
;;;
;;; For each benchmark:
;;;(...(benchmark
;;;     ((blankline))
;;;     ((indent 1) "Benchmark 3" (entry (f entry)))
;;;     ((center) "Random Text"))...)
;;;
;;; For each implementation:
;;;(...(impl "Top-row Information")...)


(declare (special *data* *benchmarks* *report-type*
		  *global-normalize* *normalize*))
(eval-when (compile) (fasload struct fas dsk (mac lsp)))

(setq *global-normalize* ()
      *normalize* ())

(defmacro string-length (str)
	  `(flatc ,str))

(defun lookup (bench impl)
       (cadr (assoc impl (cdr (assoc bench *data*)))))

(declare (special *benchmark-info*))

(defun get-bench-info (bench)
       (cdr (assoc bench *benchmark-info*)))

(declare (special *benchmark-info*))

;;; The lines of a box are segments. So a Box would look like:
;;;	<blankline>
;;;	Division by 2
;;;	<blankline>
;;;	   Recursive
;;;	   Iterative
;;;	<blankline>

(declare (special *vertical-bar* *all-boxes* *total-width* *report-type*
		  *all-implementations*))
(declare (mapex t))
(defmacro rpush (x y)
	  `(setf ,y (cons ,x ,y)))

(defun princ-n (char n)
 (break Princ-n (< n 0))
       (do ((n n (1- n)))
	   ((zerop n) t)
	   (princ char)))

(setq *vertical-bar* "|")

(defun id (() x) x)

(defstruct (box named)
	   (number-of-lines 0)
	   (width 0)
	   (lines ()))

;;; Each line is a LINE. We string Boxes together left-to-right to make
;;; a slice of the row. We paste Rows together to make the chart

(defstruct (line named)
	   (text ())
	   (pre-spaces '?)
	   (post-spaces '?)
	   (text-length '?))

(defun format-box (box)
       (let ((width (width box)))
	    (mapc #'(lambda (line)
			    (let ((tl (text-length line)))
			    (cond ((eq (pre-spaces line) '?)
				   (let ((n (// (- width tl) 2)))
					(setf (pre-spaces line) n)
					(setf (post-spaces line) 
					      (- (- width tl) n))))
				  ((eq (post-spaces line) '?)
				   (setf (post-spaces line)
					   (- width (+ tl
						       (pre-spaces line))))))))
		  (lines box))
	    t)))

(defstruct (row named)
	   (boxes ())
	   (width 0)
	   (row-type 'normal))

(defstruct (chart named)
	   (rows ()))

(defun make-a-chart (implementations)
       (let ((chart
	      (make-chart
	       rows
	       `(,(make-top-row implementations)
		 ,@(mapcan #'(lambda (bench)
				     (list (make-dashed-row)
					   (make-a-row bench implementations)))
			   *benchmarks*)
		 ,(make-dashed-row)))))
	    (assign-widths chart)
	    (find-total-width chart)
	    (format-all-boxes)
	    (find-total-width chart)
	    (print-chart chart)))

(defun make-top-row (implementations)
       (make-a-row 'Title implementations))

(defun make-dashed-row ()
       (make-row
	row-type 'dashed
	boxes
	(let ((box (make-box
		    number-of-lines 1
		    lines
		    `(,(make-line
			text-length 0)))))
	     `(,box))))

(defun make-a-row (bench implementations)
 (let* ((info
	 (get-bench-info bench))
	(len (length info))
	(best 
	 (cond ((or (and (null *normalize*)
			 (null *global-normalize*))
		    (eq bench 'title))
		(mapcar #'(lambda (()) ()) 
			info))
	       (t (find-best bench implementations)))))
  (make-row
   boxes
   `(,(let ((box 
	     (make-box
	      number-of-lines len)))
	   (push box *all-boxes*)
	   (setf (lines box)
		 (mapcar #'(lambda (line)
				   (caseq (caar line)
					  (blankline
					   (make-line
					    text-length 0))
					  (center
					   (setf (width box)
						 (max (width box)
						      (+ 2 (string-length
							    (cadr line)))))
					   (make-line
					    text-length
					    (string-length (cadr line))
					    text (cadr line)))
					  (indent
					   (setf (width box)
						 (max (width box)
						      (+
						       (cadr (car line))
						       (+ 2 (string-length
							     (cadr line))))))
					   (make-line
					    pre-spaces (cadr (car line))
					    text-length
					    (string-length (cadr line))
					    text (cadr line)))
					  (t (error "Bad Format in Left Column"))))
			 info))
	   box)
     ,(let ((box (make-box
		  number-of-lines len
		  width 1
		  lines
		  (mapcar #'(lambda (())
				    (make-line
				     text-length 1
				     text *vertical-bar*
				     pre-spaces 0
				     post-spaces 0))
			  info))))
	   (push box *all-boxes*)
	   box)
       ,@(mapcan
	  #'(lambda (impl)
		    (let ((entry
			   (cond ((atom impl)
				  (lookup bench impl))
				 (t (or (lookup bench impl)
					(mapcar #'(lambda (x)
							  (lookup bench x))
      						(cdr impl)))))))
           		 (list 
			  (let ((box
				 (make-box
				  number-of-lines len)))
			       (push box *all-boxes*)
			       (setf (lines box)
				     (mapcar 
				      #'(lambda (line best)
					 (caseq (caaddr line)
						(entry
            					 (let ((item
							(cond ((or (atom impl)
								   (atom entry))
							       (funcall (cadr (caddr line))
									impl entry))
							      (t 
           						       (apply
								(car impl)
								(mapcar 
								 #'(lambda 
								    (x y)
           							    (funcall 
								     (cadr 
								      (caddr line))
								     x y))
								 (cdr impl)
								 entry))))))
						      (cond ((not 
							      (eq bench 'title))
							     (cond ((or *normalize*
									*global-normalize*)
								    (setq item
									  (safe-quotient
									   item best))))))
						 (let ((wd
							     (cond 
							      ((null item)
							       (setq item "-")
							       1)
							      ((eq (typep item) 'symbol)
							       (flatc item)) 
							      (t (flatsize item)))))
						      (setf (width box)
							    (max (+ 2 wd)
								 (width box)))
						      (make-line
						       text-length wd
						       text item))))
						(t (make-line
						    text-length 0))))
				      info best))
			       box)
			  (let ((box 
				 (make-box
				  number-of-lines len
				  width 1
				  lines
				  (mapcar #'(lambda (())
						    (make-line
						     text-length 1
						     text *vertical-bar*
						     pre-spaces 0
						     post-spaces 0))
					  info))))
			       (push box *all-boxes*)
			       box))))
	  implementations)))
  )))

 (defun assign-widths (chart)
	(let ((columns
	       (mapcar #'(lambda (())
				 ())
		       (boxes (car (rows chart))))))
	     (do ((rows (rows chart) (cdr rows)))
		 ((null rows))
		 (caseq (row-type (car rows))
			(normal
			 (do ((cols columns (cdr cols))
			      (boxes (boxes (car rows)) (cdr boxes)))
			     ((null boxes))
			     (rpush (car boxes) (car cols))))
			))
	     (mapcar
	      #'(lambda (col)
			(let ((maximum 0))
			     (mapc
			      #'(lambda (box)
					(setq maximum
					      (max maximum
						   (width box))))
			      col)
			     (mapc
			      #'(lambda (box)
					(setf (width box) maximum))
			      col)))
	      columns))
	t)

(defun format-all-boxes ()
       (mapc #'format-box *all-boxes*))

(defun find-total-width (chart)
       (setq *total-width* 0)
       (mapc #'(lambda (box)
		       (setq *total-width*
			     (+ *total-width*
				(width box))))
	     (boxes (car (rows chart))))
       t))

(defun print-chart (chart)
       (mapc #'print-row (rows chart))
       t)

(defun print-row (row)
       (terpri)
       (cond ((eq (row-type row) 'dashed)
	      (princ-n "-" (1- *total-width*)) (princ *vertical-bar*))
	     (t 
	      (print-boxes (boxes row))))
       t) 

(defun print-boxes (boxes)
       (let ((n (number-of-lines (car boxes))))
	    (do ((i 0 (1+ i)))
		((= i n))
		(terpri)
		(print-line-n boxes i))))

(defun print-line-n (boxes n)
       (mapc #'(lambda (box)
		       (print-line (nth n (lines box))))
	     boxes)
       t)

(defun print-line (line)
       (princ-n " " (pre-spaces line))
       (or (zerop (text-length line))
	   (princ (text line)))
       (princ-n " " (post-spaces line))
       t)

(defun do-chart (implementations)
       (setq *all-boxes* ()
	     *total-width* 0)
       (make-a-chart
	implementations))

(defun find-best (bench implementations)
       (let ((info
	      (get-bench-info bench)))
	    (mapcar 
	     #'(lambda (entry)
		       (let* ((fun
			       (let ((x (car (last entry))))
				    (cond ((not (atom x))
					   (cadr x))
					  (t ()))))
			      (entries
			       (mapcar
				#'(lambda (impl)
					  (let ((entry (lookup bench impl)))
					       (cond (entry
						      (and fun (funcall fun impl entry))))))
				implementations)))
			     (and fun
				  (cond (*normalize*
					 (let ((best (car entries)))
					      (cond 
					       (*global-normalize*
						(cond 
						 ((not (eq *global-normalize* 't))
						  (let ((entry
							 (lookup bench *global-normalize*)))
						       (cond ((and fun entry)
							      (setq best 
								    (funcall fun 
									     *global-normalize*
									     entry))))))
						 (t (let 
						     ((all-entries
						       (mapcar
							#'(lambda (impl)
								  (let ((entry (lookup bench (car impl))))
								       (cond (entry
									      (funcall fun (car impl) entry)))))
							*all-implementations*)))
						     (do ((entries (cdr all-entries) (cdr entries)))
							 ((null entries))
							 (cond ((and (numberp 
								      (car entries))
								     (numberp best)
								     (lessp (car entries) 
									    best))
								(setq best (car entries)))))))))
					       (t					
						(do ((entries (cdr entries) (cdr entries)))
						    ((null entries))
						    (cond ((and (numberp 
								 (car entries))
								(numberp best)
								(lessp (car entries) 
								       best))
							   (setq best (car entries)))))))
					      best))))))
	     info)))